COMMENT ⊗   VALID 00003 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 More metering system
C00010 00003	 For the metering system
C00014 ENDMK
C⊗;
;;; More metering system
(eval-when (eval compile)
 (setq meter:refi (meter:make-name 'meter:refi)
       meter:refr (meter:make-name 'meter:refr)
       meter:array-size (meter:make-name 'meter:array-size)))

(declare 
 (*expr #.meter:refi
	#.meter:refr))

(eval-when (compile)
	   (setq old-fixsw fixsw)(fixsw ()))

(eval-when (eval compile)
	   (cond (meter:count-only (read))))

(defun #.(meter:make-name 'meter:report) ()
       (declare (flonum total-ops total-time))
       (terpri)
       (princ '|Statistics|)
       (terpri)
       (princ '|= <calls> (<percentage>) [runtime (<percentage>)]|)
       (terpri)
       (let ((d-ar (get #.(meter:make-name 'meter:array-name) 'array))
	     (c-ar (get #.(meter:make-name 'meter:comment-name) 'array)))
	    (do ((i 0 (1+ i)))
		((> i #.(meter:make-name 'meter:maxf)) t)
		(terpri)(terpri)
		(princ '|Meter for: |)
		(princ (arraycall t c-ar i 0))
		(terpri)
		(let ((total-ops 0.0) 
		      (total-time 0.0)
		      (max (arraycall fixnum d-ar i)))
		     (do ((n 1 (1+ n))
			  (total (#.meter:refi
				  (* #.meter:factor i))
				 (+ total (#.meter:refi
					   (+ (* #.meter:factor i) 
					      n))))
			  (total-run (#.meter:refr
				      (* #.meter:factor i))
				     (+ total-run 
					(#.meter:refr
					 (+ (* #.meter:factor i) n)))))
			 ((> n max) (setq total-ops (float total)
					  total-time 
					  (cond ((boundp 'meter:real-runtime) 
						 (*$ 1000.0
						     (float meter:real-runtime)))
						(t (float total-run))))))
		     (do ((n 0 (1+ n)))
			 ((> n max) 
			  (princ '|Total = |)(princ (fix total-ops))
			  (tyo #o9) (princ (//$ total-time 1000.0))
			  (terpri))
			 (princ (arraycall t c-ar i (1+ n)))
			 (princ '| = |)
			 (let ((x (#.meter:refi (+ (* #.meter:factor i) n)))
			       (y (#.meter:refr (+ (* #.meter:factor i) n))))
			      (princ x)
			      (princ '| (|)
			      (princ (//$ 
				      (float 
				       (fix 
					(*$ 10000.0 
					    (+$ .00005
						(//$ (float x)
						     total-ops))))) 
				      100.0))
			      (princ '|%)|)
			      (princ '| |)
			      (princ '|[|)
			      (princ (//$ (float y) 1000.0))
			      (princ '| (|)
			      (princ (//$ 
				      (float 
				       (fix 
					(*$ 10000.0 
					    (+$ .00005
						(//$ (float y)
						     total-time))))) 
				      100.0))
			      (princ '|%)]|))
			 (terpri))))))

(eval-when (eval compile)
	   (cond ((not meter:count-only) (read))))

(defun #.(meter:make-name 'meter:report) ()
       (declare (flonum total-ops))
       (terpri)
       (princ '|Statistics|)
       (terpri)
       (princ '|= <calls> (<percentage>)|)
       (terpri)
       (let ((d-ar (get #.(meter:make-name 'meter:array-name) 'array))
	     (c-ar (get #.(meter:make-name 'meter:comment-name) 'array))
	     (cnt-ar (get #.(meter:make-name 'meter:count-array-name) 'array)))
	    (do ((i 0 (1+ i)))
		((> i #.(meter:make-name 'meter:maxf)) t)
		(terpri)(terpri)
		(princ '|Meter for: |)
		(princ (arraycall t c-ar i 0))
		(terpri)
		(let ((total-ops 0.0) 
		      (max (arraycall fixnum d-ar i)))
		     (do ((n 1 (1+ n))
			  (total (arraycall fixnum cnt-ar
				  (* #.meter:factor i))
				 (+ total (arraycall fixnum cnt-ar
					   (+ (* #.meter:factor i) 
					      n)))))
			 ((> n max) (setq total-ops (float total))))
		     (do ((n 0 (1+ n)))
			 ((> n max) 
			  (princ '|Total = |)(princ (fix total-ops))
			  (terpri))
			 (princ (arraycall t c-ar i (1+ n)))
			 (princ '| = |)
			 (let ((x (arraycall fixnum cnt-ar
			           (+ (* #.meter:factor i) n))))
			      (princ x)
			      (princ '| (|)
			      (princ (//$ 
				      (float 
				       (fix 
					(*$ 10000.0 
					    (+$ .00005
						(//$ (float x)
						     total-ops))))) 
				      100.0))
			      (princ '|%)|))
			 (terpri))))))

(defun #.(meter:make-name 'meter:init) ()
 #.(cond (meter:count-only `(fillarray ,meter:count-array-name '(0))))
 (#.(meter:make-name 'meter:init-arrays) #.(meter:make-name 'meter:array-size)))

(eval-when (compile)
	   (funcall #'fixsw old-fixsw))
;;; For the metering system
;;; metaux.lap
;;; LAP stuff

(lap #.(meter:make-name 'meter:init-arrays) subr)
(args #.(meter:make-name 'meter:init-arrays) (nil . 1))
	(move t 0 a)
	(lsh t 1)
	(addi t (- arr 1))
	(setzm 0 arr)
	(hrli tt arr)
	(hrri tt arr)
	(addi tt 1)
	(blt tt 0 t)
	(movei a 't)
	(popj p)

;;; (meter:start-time)
(entry #.(meter:make-name 'meter:start-time) subr)
(args #.(meter:make-name 'meter:start-time) (nil . 0))
	(movei tt 0)
	(calli tt #o27)
	(exch fxp pdl)
	(push fxp tt)
	(exch fxp pdl)
	(movei a 't)
	(popj p)

;;; (meter:end-time <n> <increment>)
(entry #.(meter:make-name 'meter:end-time) subr)
(args #.(meter:make-name 'meter:end-time) (nil . 2))
	(movei tt 0)
	(calli tt #o27)
	(exch fxp pdl)
	(pop fxp t)
	(exch fxp pdl)
	(sub tt t)
	(move t 0 a)	;get index
	(addi t arr)
	(addm tt 0 t)
	(add t size)	;into next array
	(move b 0 b)	
	(addm b 0 t)	;increment
	(popj p)	;return the function-number

;;; (meter:inc-only <n> <increment>)
(entry #.(meter:make-name 'meter:inc-only) subr)
(args #.(meter:make-name 'meter:inc-only) (nil . 2))
	(move t 0 a)	;get index
	(addi t ari)
	(move b 0 b)
	(addm b 0 t)
	(popj p)	;return the function-number

;;; (meter:refr <n>)
(entry #.(meter:make-name 'meter:refr) subr)
(args #.(meter:make-name 'meter:refr) (nil . 1))
	(move t 0 a)	;get index
	(addi t arr)
	(move tt 0 t)
	(jrst 0 fix1)

;;; (meter:refi <n>)
(entry #.(meter:make-name 'meter:refi) subr)
(args #.(meter:make-name 'meter:refi) (nil . 1))
	(move t 0 a)	;get index
	(addi t ari)
	(move tt 0 t)
	(jrst 0 fix1)

size (#.(symeval meter:array-size))
arr (block #.(symeval meter:array-size))
ari (block #.(symeval meter:array-size))
stack (block 2000)
pdl (776000←22 0 stack)
inipdl (776000←22 0 stack)
()